home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / user2.lsp < prev   
Encoding:
Lisp/Scheme  |  1993-06-05  |  33.7 KB  |  847 lines
  1. ;;;; User-Interface, Teil 2
  2. ;;;; Funktionen fürs Debugging (Kapitel 25.3)
  3. ;;;; Apropos, Describe, Dribble, Ed
  4. ;;;; 27.6.1992
  5.  
  6. (in-package "LISP")
  7. (export '(*editor* editor-tempfile edit-file saveinitmem))
  8. (in-package "SYSTEM")
  9.  
  10. ;-------------------------------------------------------------------------------
  11. ;; APROPOS
  12.  
  13. (defun apropos-list (string &optional (package nil))
  14.   (let* ((L nil)
  15.          (fun #'(lambda (sym)
  16.                   (when
  17.                       #| (search string (symbol-name sym) :test #'char-equal) |#
  18.                       (sys::search-string-equal string sym) ; 15 mal schneller!
  19.                     (push sym L)
  20.                 ) )
  21.         ))
  22.     (if package
  23.       (system::map-symbols fun package)
  24.       (system::map-all-symbols fun)
  25.     )
  26.     (sort L #'string< :key #'symbol-name)
  27. ) )
  28.  
  29. (defun fbound-string (sym) ; liefert den Typ eines Symbols sym mit (fboundp sym)
  30.   (cond ((special-form-p sym)
  31.          #+DEUTSCH "Spezialform"
  32.          #+ENGLISH "special form"
  33.          #+FRANCAIS "forme spéciale"
  34.         )
  35.         ((functionp (symbol-function sym))
  36.          #+DEUTSCH "Funktion"
  37.          #+ENGLISH "function"
  38.          #+FRANCAIS "fonction"
  39.         )
  40.         (t #+DEUTSCH "Macro"
  41.            #+ENGLISH "macro"
  42.            #+FRANCAIS "macro"
  43. ) )     )
  44.  
  45. (defun apropos (string &optional (package nil))
  46.   (dolist (sym (apropos-list string package))
  47.     (print sym)
  48.     (when (fboundp sym)
  49.       (write-string "   ")
  50.       (write-string (fbound-string sym))
  51.     )
  52.     (when (boundp sym)
  53.       (write-string "   ")
  54.       (if (constantp sym)
  55.         (write-string #+DEUTSCH "Konstante"
  56.                       #+ENGLISH "constant"
  57.                       #+FRANCAIS "constante"
  58.         )
  59.         (write-string #+DEUTSCH "Variable"
  60.                       #+ENGLISH "variable"
  61.                       #+FRANCAIS "variable"
  62.   ) ) ) )
  63.   (values)
  64. )
  65.  
  66. ;-------------------------------------------------------------------------------
  67. ;; DESCRIBE
  68.  
  69. (defun describe (obj &aux (more '()))
  70.   (format t #+DEUTSCH "~%Beschreibung von~%"
  71.             #+ENGLISH "~%Description of~%"
  72.             #+FRANCAIS "~%Description de~%"
  73.   )
  74.   (format t "~A" (write-to-short-string obj sys::*prin-linelength*))
  75.   (format t #+DEUTSCH "~%Das ist "
  76.             #+ENGLISH "~%This is "
  77.             #+FRANCAIS "~%Ceci est "
  78.   )
  79.   (let ((type (type-of obj)))
  80.     ; Dispatch nach den möglichen Resultaten von TYPE-OF:
  81.     (if (atom type)
  82.       (case type
  83.         (CONS
  84.           (flet ((list-length (list)  ; vgl. CLTL, S. 265
  85.                    (do ((n 0 (+ n 2))
  86.                         (fast list (cddr fast))
  87.                         (slow list (cdr slow))
  88.                        )
  89.                        (nil)
  90.                      (when (atom fast) (return n))
  91.                      (when (atom (cdr fast)) (return (1+ n)))
  92.                      (when (eq (cdr fast) slow) (return nil))
  93.                 )) )
  94.             (let ((len (list-length obj)))
  95.               (if len
  96.                 (if (null (nthcdr len obj))
  97.                   (format t #+DEUTSCH "eine Liste der Länge ~S."
  98.                             #+ENGLISH "a list of length ~S."
  99.                             len
  100.                   )
  101.                   (if (> len 1)
  102.                     (format t #+DEUTSCH "eine punktierte Liste der Länge ~S."
  103.                               #+ENGLISH "a dotted list of length ~S."
  104.                               len
  105.                     )
  106.                     (format t #+DEUTSCH "ein Cons."
  107.                               #+ENGLISH "a cons."
  108.                 ) ) )
  109.                 (format t #+DEUTSCH "eine zyklische Liste."
  110.                           #+ENGLISH "a cyclic list."
  111.         ) ) ) ) )
  112.         ((SYMBOL NULL)
  113.           (when (null obj)
  114.             (format t #+DEUTSCH "die leere Liste, "
  115.                       #+ENGLISH "the empty list, "
  116.           ) )
  117.           (format t #+DEUTSCH "das Symbol ~S"
  118.                     #+ENGLISH "the symbol ~S"
  119.                     obj
  120.           )
  121.           (when (keywordp obj)
  122.             (format t #+DEUTSCH ", ein Keyword"
  123.                       #+ENGLISH ", a keyword"
  124.           ) )
  125.           (when (boundp obj)
  126.             (if (constantp obj)
  127.               (format t #+DEUTSCH ", eine Konstante"
  128.                         #+ENGLISH ", a constant"
  129.               )
  130.               (if (sys::special-variable-p obj)
  131.                 (format t #+DEUTSCH ", eine SPECIAL-deklarierte Variable"
  132.                           #+ENGLISH ", a variable declared SPECIAL"
  133.                 )
  134.                 (format t #+DEUTSCH ", eine Variable"
  135.                           #+ENGLISH ", a variable"
  136.             ) ) )
  137.             (push `,obj more)
  138.             (push `(SYMBOL-VALUE ',obj) more)
  139.           )
  140.           (when (fboundp obj)
  141.             (format t #+DEUTSCH ", benennt "
  142.                       #+ENGLISH ", names "
  143.             )
  144.             (cond ((special-form-p obj)
  145.                    (format t #+DEUTSCH "eine Special-Form"
  146.                              #+ENGLISH "a special form"
  147.                    )
  148.                    (when (macro-function obj)
  149.                      (format t #+DEUTSCH " mit Macro-Definition"
  150.                                #+ENGLISH " with macro definition"
  151.                   )) )
  152.                   ((functionp (symbol-function obj))
  153.                    (format t #+DEUTSCH "eine Funktion"
  154.                              #+ENGLISH "a function"
  155.                    )
  156.                    (push `#',obj more)
  157.                    (push `(SYMBOL-FUNCTION ',obj) more)
  158.                   )
  159.                   (t ; (macro-function obj)
  160.                    (format t #+DEUTSCH "einen Macro"
  161.                              #+ENGLISH "a macro"
  162.                   ))
  163.           ) )
  164.           (when (symbol-plist obj)
  165.             (let ((properties
  166.                     (do ((l nil)
  167.                          (pl (symbol-plist obj) (cddr pl)))
  168.                         ((null pl) (nreverse l))
  169.                       (push (car pl) l)
  170.                  )) )
  171.               (format t #+DEUTSCH ", hat die Propert~@P ~{~S~^, ~}"
  172.                         #+ENGLISH ", has the propert~@P ~{~S~^, ~}"
  173.                         (length properties) properties
  174.             ) )
  175.             (push `(SYMBOL-PLIST ',obj) more)
  176.           )
  177.           (format t #+DEUTSCH "."
  178.                     #+ENGLISH "."
  179.           )
  180.           (format t #+DEUTSCH "~%Das Symbol "
  181.                     #+ENGLISH "~%The symbol "
  182.           )
  183.           (let ((home (symbol-package obj)))
  184.             (if home
  185.               (format t #+DEUTSCH "liegt in ~S"
  186.                         #+ENGLISH "lies in ~S"
  187.                         home
  188.               )
  189.               (format t #+DEUTSCH "ist uninterniert"
  190.                         #+ENGLISH "is uninterned"
  191.             ) )
  192.             (let ((accessible-packs nil))
  193.               (let ((normal-printout ; externe Repräsentation ohne Package-Marker
  194.                       (if home
  195.                         (let ((*package* home)) (prin1-to-string obj))
  196.                         (let ((*print-gensym* nil)) (prin1-to-string obj))
  197.                    )) )
  198.                 (dolist (pack (list-all-packages))
  199.                   (when ; obj in pack accessible?
  200.                         (string=
  201.                           (let ((*package* pack)) (prin1-to-string obj))
  202.                           normal-printout
  203.                         )
  204.                     (push pack accessible-packs)
  205.               ) ) )
  206.               (when accessible-packs
  207.                 (format t #+DEUTSCH " und ist in ~:[der Package~;den Packages~] ~{~A~^, ~} accessible"
  208.                           #+ENGLISH " and is accessible in the package~:[~;s~] ~{~A~^, ~}"
  209.                           (cdr accessible-packs)
  210.                           (sort (mapcar #'package-name accessible-packs) #'string<)
  211.           ) ) ) )
  212.           (format t #+DEUTSCH "."
  213.                     #+ENGLISH "."
  214.         ) )
  215.         ((FIXNUM BIGNUM)
  216.           (format t #+DEUTSCH "eine ganze Zahl, belegt ~S Bits, ist als ~:(~A~) repräsentiert."
  217.                     #+ENGLISH "an integer, uses ~S bits, is represented as a ~(~A~)."
  218.                     (integer-length obj) type
  219.         ) )
  220.         (RATIO
  221.           (format t #+DEUTSCH "eine rationale, nicht ganze Zahl."
  222.                     #+ENGLISH "a rational, not integral number."
  223.         ) )
  224.         ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
  225.           (format t #+DEUTSCH "eine Fließkommazahl mit ~S Mantissenbits (~:(~A~))."
  226.                     #+ENGLISH "a float with ~S bits of mantissa (~(~A~))."
  227.                     (float-digits obj) type
  228.         ) )
  229.         (COMPLEX
  230.           (format t #+DEUTSCH "eine komplexe Zahl "
  231.                     #+ENGLISH "a complex number "
  232.           )
  233.           (let ((x (realpart obj))
  234.                 (y (imagpart obj)))
  235.             (if (zerop y)
  236.               (if (zerop x)
  237.                 (format t #+DEUTSCH "im Ursprung"
  238.                           #+ENGLISH "at the origin"
  239.                 )
  240.                 (format t #+DEUTSCH "auf der ~:[posi~;nega~]tiven reellen Achse"
  241.                           #+ENGLISH "on the ~:[posi~;nega~]tive real axis"
  242.                           (minusp x)
  243.               ) )
  244.               (if (zerop x)
  245.                 (format t #+DEUTSCH "auf der ~:[posi~;nega~]tiven imaginären Achse"
  246.                           #+ENGLISH "on the ~:[posi~;nega~]tive imaginary axis"
  247.                           (minusp y)
  248.                 )
  249.                 (format t #+DEUTSCH "im ~:[~:[ers~;vier~]~;~:[zwei~;drit~]~]ten Quadranten"
  250.                           #+ENGLISH "in ~:[~:[first~;fourth~]~;~:[second~;third~]~] the quadrant"
  251.                           (minusp x) (minusp y)
  252.           ) ) ) )
  253.           (format t #+DEUTSCH " der Gaußschen Zahlenebene."
  254.                     #+ENGLISH " of the Gaussian number plane."
  255.         ) )
  256.         (CHARACTER
  257.           (format t #+DEUTSCH "ein Zeichen"
  258.                     #+ENGLISH "a character"
  259.           )
  260.           (unless (zerop (char-bits obj))
  261.             (format t #+DEUTSCH " mit Zusatzbits"
  262.                       #+ENGLISH " with additional bits"
  263.           ) )
  264.           (unless (zerop (char-font obj))
  265.             (format t #+DEUTSCH " aus Zeichensatz ~S"
  266.                       #+ENGLISH " from font ~S"
  267.                       (char-font obj)
  268.           ) )
  269.           (format t #+DEUTSCH "."
  270.                     #+ENGLISH "."
  271.           )
  272.           (format t #+DEUTSCH "~%Es ist ein ~:[nicht ~;~]druckbares Zeichen."
  273.                     #+ENGLISH "~%It is a ~:[non-~;~]printable character."
  274.                     (graphic-char-p obj)
  275.           )
  276.           (unless (standard-char-p obj)
  277.             (format t #+DEUTSCH "~%Seine Verwendung ist nicht portabel."
  278.                       #+ENGLISH "~%Its use is non-portable."
  279.           ) )
  280.         )
  281.         (FUNCTION ; (SYS::CLOSUREP obj) ist erfüllt
  282.           (let ((compiledp (compiled-function-p obj)))
  283.             (format t #+DEUTSCH "eine ~:[interpret~;compil~]ierte Funktion."
  284.                       #+ENGLISH "an ~:[interpret~;compil~]ed function."
  285.                       compiledp
  286.             )
  287.             (if compiledp
  288.               (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  289.                   (sys::signature obj)
  290.                 (describe-signature req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  291.                 (push `(DISASSEMBLE #',(sys::closure-name obj)) more)
  292.                 (push `(DISASSEMBLE ',obj) more)
  293.               )
  294.               (progn
  295.                 (format t #+DEUTSCH "~%Argumentliste: ~S"
  296.                           #+ENGLISH "~%argument list: ~S"
  297.                           (car (sys::%record-ref obj 1))
  298.                 )
  299.                 (let ((doc (sys::%record-ref obj 2)))
  300.                   (when doc
  301.                     (format t #+DEUTSCH "~%Dokumentation: ~A"
  302.                               #+ENGLISH "~%documentation: ~A"
  303.                               doc
  304.               ) ) ) )
  305.         ) ) )
  306.         (COMPILED-FUNCTION ; nur SUBRs und FSUBRs
  307.           (if (functionp obj)
  308.             ; SUBR
  309.             (progn
  310.               (format t #+DEUTSCH "eine eingebaute System-Funktion."
  311.                         #+ENGLISH "a built-in system function."
  312.               )
  313.               (multiple-value-bind (name req-anz opt-anz rest-p keywords allow-other-keys)
  314.                   (sys::subr-info obj)
  315.                 (when name
  316.                   (describe-signature req-anz opt-anz rest-p keywords keywords allow-other-keys)
  317.             ) ) )
  318.             ; FSUBR
  319.             (format t #+DEUTSCH "ein Special-Form-Handler."
  320.                       #+ENGLISH "a special form handler."
  321.         ) ) )
  322.         (STREAM
  323.           (format t #+DEUTSCH "ein ~:[~:[geschlossener ~;Output-~]~;~:[Input-~;bidirektionaler ~]~]Stream."
  324.                     #+ENGLISH "a~:[~:[ closed ~;n output-~]~;~:[n input-~;n input/output-~]~]stream."
  325.                     (input-stream-p obj) (output-stream-p obj)
  326.         ) )
  327.         (PACKAGE
  328.           (format t #+DEUTSCH "die Package mit Namen ~A"
  329.                     #+ENGLISH "the package named ~A"
  330.                     (package-name obj)
  331.           )
  332.           (let ((nicknames (package-nicknames obj)))
  333.             (when nicknames
  334.               (format t #+DEUTSCH " und zusätzlichen Namen ~{~A~^, ~}"
  335.                         #+ENGLISH ". It has the nicknames ~{~A~^, ~}"
  336.                         nicknames
  337.           ) ) )
  338.           (format t #+DEUTSCH "."
  339.                     #+ENGLISH "."
  340.           )
  341.           (let ((use-list (package-use-list obj))
  342.                 (used-by-list (package-used-by-list obj)))
  343.             (format t #+DEUTSCH "~%Sie "
  344.                       #+ENGLISH "~%It "
  345.             )
  346.             (when use-list
  347.               (format t #+DEUTSCH "importiert die externen Symbole der Package~:[~;s~] ~{~A~^, ~} und "
  348.                         #+ENGLISH "imports the external symbols of the package~:[~;s~] ~{~A~^, ~} and "
  349.                         (cdr use-list) (mapcar #'package-name use-list)
  350.             ) )
  351.             (format t #+DEUTSCH "exportiert ~:[keine Symbole~;die Symbole ~:*~{~S~^ ~}~]"
  352.                       #+ENGLISH "exports ~:[no symbols~;the symbols ~:*~{~S~^ ~}~]"
  353.                       ; Liste aller exportierten Symbole:
  354.                       (let ((L nil))
  355.                         (do-external-symbols (s obj) (push s L))
  356.                         (sort L #'string< :key #'symbol-name)
  357.             )         )
  358.             (when used-by-list
  359.               (format t #+DEUTSCH " an die Package~:[~;s~] ~{~A~^, ~}"
  360.                         #+ENGLISH " to the package~:[~;s~] ~{~A~^, ~}"
  361.                         (cdr used-by-list) (mapcar #'package-name used-by-list)
  362.             ) )
  363.             (format t #+DEUTSCH "."
  364.                       #+ENGLISH "."
  365.         ) ) )
  366.         (HASH-TABLE
  367.           (format t #+DEUTSCH "eine Hash-Tabelle mit ~S Eintr~:*~[ägen~;ag~:;ägen~]."
  368.                     #+ENGLISH "a hash table with ~S entr~:@P."
  369.                     (hash-table-count obj)
  370.         ) )
  371.         (READTABLE
  372.           (format t #+DEUTSCH "~:[eine ~;die Common-Lisp-~]Readtable."
  373.                     #+ENGLISH "~:[a~;the Common Lisp~] readtable."
  374.                     (equalp obj (copy-readtable))
  375.         ) )
  376.         (PATHNAME
  377.           (format t #+DEUTSCH "ein Pathname~:[.~;~:*, aufgebaut aus:~{~A~}~]"
  378.                     #+ENGLISH "a pathname~:[.~;~:*, with the following components:~{~A~}~]"
  379.                     (mapcan #'(lambda (kw component)
  380.                                 (when component
  381.                                   (list (format nil "~%~A = ~A"
  382.                                                     (symbol-name kw)
  383.                                                     (make-pathname kw component)
  384.                               ) ) )     )
  385.                       '(:host :device :directory :name :type :version)
  386.                       (list
  387.                         (pathname-host obj)
  388.                         (pathname-device obj)
  389.                         (pathname-directory obj)
  390.                         (pathname-name obj)
  391.                         (pathname-type obj)
  392.                         (pathname-version obj)
  393.         ) )         ) )
  394.         (RANDOM-STATE
  395.           (format t #+DEUTSCH "ein Random-State."
  396.                     #+ENGLISH "a random-state."
  397.         ) )
  398.         (BYTE
  399.           (format t #+DEUTSCH "ein Byte-Specifier, bezeichnet die ~S Bits ab Bitposition ~S eines Integers."
  400.                     #+ENGLISH "a byte specifier, denoting the ~S bits starting at bit position ~S of an integer."
  401.                     (byte-size obj) (byte-position obj)
  402.         ) )
  403.         (LOAD-TIME-EVAL
  404.           (format t #+DEUTSCH "eine Absicht der Evaluierung zur Ladezeit." ; ??
  405.                     #+ENGLISH "a load-time evaluation promise." ; ??
  406.         ) )
  407.         (READ-LABEL
  408.           (format t #+DEUTSCH "eine Markierung zur Auflösung von #~D#-Verweisen bei READ."
  409.                     #+ENGLISH "a label used for resolving #~D# references during READ."
  410.                     (logand (sys::address-of obj) '#,(ash most-positive-fixnum -1))
  411.         ) )
  412.         (FRAME-POINTER
  413.           (format t #+DEUTSCH "ein Pointer in den Stack. Er zeigt auf:"
  414.                     #+ENGLISH "a pointer into the stack. It points to:"
  415.           )
  416.           (sys::describe-frame obj)
  417.         )
  418.         (SYSTEM-INTERNAL
  419.           (format t #+DEUTSCH "ein Objekt mit besonderen Eigenschaften."
  420.                     #+ENGLISH "a special-purpose object."
  421.         ) )
  422.         (ADDRESS
  423.           (format t #+DEUTSCH "eine Maschinen-Adresse."
  424.                     #+ENGLISH "a machine address."
  425.         ) )
  426.         (t ; Structure
  427.           (format t #+DEUTSCH "eine Structure vom Typ ~S."
  428.                     #+ENGLISH "a structure of type ~S."
  429.                     type
  430.           )
  431.           (let ((type (sys::%record-ref obj 0)))
  432.             (when (consp type)
  433.               (format t #+DEUTSCH "~%Als solche ist sie auch eine Structure vom Typ ~{~S~^, ~}."
  434.                         #+ENGLISH "~%As such, it is also a structure of type ~{~S~^, ~}."
  435.                         (cdr (nreverse (cons (cdr (last type)) (reverse type))))
  436.         ) ) ) )
  437.       )
  438.       ; Array-Typen
  439.       (let ((rank (array-rank obj))
  440.             (eltype (array-element-type obj)))
  441.         (format t #+DEUTSCH "ein~:[~; einfacher~] ~A-dimensionaler Array"
  442.                   #+ENGLISH "a~:[~; simple~] ~R dimensional array"
  443.                   (simple-array-p obj) rank
  444.         )
  445.         (when (eql rank 1)
  446.           (format t #+DEUTSCH " (Vektor)"
  447.                     #+ENGLISH " (vector)"
  448.         ) )
  449.         (unless (eq eltype 'T)
  450.           (format t #+DEUTSCH " von ~:(~A~)s"
  451.                     #+ENGLISH " of ~(~A~)s"
  452.                     eltype
  453.         ) )
  454.         (when (adjustable-array-p obj)
  455.           (format t #+DEUTSCH ", adjustierbar"
  456.                     #+ENGLISH ", adjustable"
  457.         ) )
  458.         (when (plusp rank)
  459.           (format t #+DEUTSCH ", der Größe ~{~S~^ x ~}"
  460.                     #+ENGLISH ", of size ~{~S~^ x ~}"
  461.                     (array-dimensions obj)
  462.           )
  463.           (when (array-has-fill-pointer-p obj)
  464.             (format t #+DEUTSCH " und der momentanen Länge (Fill-Pointer) ~S"
  465.                       #+ENGLISH " and current length (fill-pointer) ~S"
  466.                       (fill-pointer obj)
  467.         ) ) )
  468.         (format t #+DEUTSCH "."
  469.                   #+ENGLISH "."
  470.       ) )
  471.   ) )
  472.   (when more
  473.     (format t #+DEUTSCH "~%Mehr Information durch Auswerten von ~{~S~^ oder ~}."
  474.               #+ENGLISH "~%For more information, evaluate ~{~S~^ or ~}."
  475.               (nreverse more)
  476.   ) )
  477.   (values)
  478. )
  479.  
  480. (defun describe-signature (req-anz opt-anz rest-p keyword-p keywords allow-other-keys)
  481.   (format t #+DEUTSCH "~%Argumentliste: "
  482.             #+ENGLISH "~%argument list: "
  483.   )
  484.   (format t "(~{~A~^ ~})"
  485.     (let ((args '()) (count 0))
  486.       (dotimes (i req-anz)
  487.         (incf count)
  488.         (push (format nil "ARG~D" count) args)
  489.       )
  490.       (when (plusp opt-anz)
  491.         (push '&OPTIONAL args)
  492.         (dotimes (i opt-anz)
  493.           (incf count)
  494.           (push (format nil "ARG~D" count) args)
  495.       ) )
  496.       (when rest-p
  497.         (push '&REST args)
  498.         (push "OTHER-ARGS" args)
  499.       )
  500.       (when keyword-p
  501.         (push '&KEY args)
  502.         (dolist (kw keywords) (push (prin1-to-string kw) args))
  503.         (when allow-other-keys (push '&ALLOW-OTHER-KEYS args))
  504.       )
  505.       (nreverse args)
  506. ) ) )
  507. ;; DOCUMENTATION mit abfragen und ausgeben??
  508. ;; function, variable, type, structure, setf
  509.  
  510. ; Gibt object in einen String aus, der nach Möglichkeit höchstens max Zeichen
  511. ; lang sein soll.
  512. (defun write-to-short-string (object max)
  513.   ; Methode: probiere
  514.   ; level = 0: length = 0,1,2
  515.   ; level = 1: length = 1,2,3,4
  516.   ; level = 2: length = 2,...,6
  517.   ; usw. bis maximal level = 16.
  518.   ; Dabei level möglichst groß, und bei festem level length möglichst groß.
  519.   (if (or (numberp object) (symbolp object)) ; von length und level unbeeinflußt?
  520.     (write-to-string object)
  521.     (macrolet ((minlength (level) `,level)
  522.                (maxlength (level) `(* 2 (+ ,level 1))))
  523.       ; Um level möglist groß zu bekommen, dabei length = minlength wählen.
  524.       (let* ((level ; Binärsuche nach dem richtigen level
  525.                (let ((level1 0) (level2 16))
  526.                  (loop
  527.                    (when (= (- level2 level1) 1) (return))
  528.                    (let ((levelm (floor (+ level1 level2) 2)))
  529.                      (if (<= (length (write-to-string object :level levelm :length (minlength levelm))) max)
  530.                        (setq level1 levelm) ; levelm paßt, probiere größere
  531.                        (setq level2 levelm) ; levelm paßt nicht, probiere kleinere
  532.                  ) ) )
  533.                  level1
  534.              ) )
  535.              (length ; Binärsuche nach dem richtigen length
  536.                (let ((length1 (minlength level)) (length2 (maxlength level)))
  537.                  (loop
  538.                    (when (= (- length2 length1) 1) (return))
  539.                    (let ((lengthm (floor (+ length1 length2) 2)))
  540.                      (if (<= (length (write-to-string object :level level :length lengthm)) max)
  541.                        (setq length1 lengthm) ; lengthm paßt, probiere größere
  542.                        (setq length2 lengthm) ; lengthm paßt nicht, probiere kleinere
  543.                  ) ) )
  544.                  length1
  545.             )) )
  546.         (write-to-string object :level level :length length)
  547. ) ) ) )
  548.  
  549. ;-------------------------------------------------------------------------------
  550. ;; DRIBBLE
  551.  
  552. (let ((dribble-file nil) (dribbled-input nil) (dribbled-output nil))
  553.   (defun dribble (&optional file)
  554.     (if file
  555.       (progn
  556.         (if dribble-file
  557.           (warn #+DEUTSCH "Es wird bereits auf ~S protokolliert."
  558.                 #+ENGLISH "Already dribbling to ~S"
  559.                 #+FRANCAIS "Le protocole est déjà écrit sur ~S."
  560.                 dribble-file
  561.           )
  562.           (setq dribble-file (open file :direction :output)
  563.                 dribbled-input *standard-input*
  564.                 dribbled-output *standard-output*
  565.                 *standard-input* (make-echo-stream *standard-input* dribble-file)
  566.                 *standard-output* (make-broadcast-stream *standard-output* dribble-file)
  567.         ) )
  568.         dribble-file
  569.       )
  570.       (if dribble-file
  571.         (prog2
  572.           (setq *standard-input* dribbled-input
  573.                 *standard-output* dribbled-output
  574.                 dribbled-input nil
  575.                 dribbled-output nil
  576.           )
  577.           dribble-file
  578.           (close dribble-file)
  579.           (setq dribble-file nil)
  580.         )
  581.         (warn #+DEUTSCH "Es wird zur Zeit nicht protokolliert."
  582.               #+ENGLISH "Currently not dribbling."
  583.               #+FRANCAIS "Aucun protocole n'est couramment écrit."
  584. ) ) ) ) )
  585.  
  586. ;-------------------------------------------------------------------------------
  587. ;; ED
  588.  
  589. ;; *editor* und editor-tempfile sind in CONFIG.LSP definiert.
  590. ;; Hier stehen nur die Defaults.
  591.  
  592. ;; Der Name des Editors:
  593. (defparameter *editor* nil)
  594.  
  595. ;; Das temporäre File, das LISP beim Editieren anlegt:
  596. (defun editor-tempfile ()
  597.   #+(or ATARI DOS) "LISPTEMP.LSP"
  598.   #+OS/2 "lisptemp.lsp"
  599.   #+AMIGA "T:lisptemp.lsp"
  600.   #+(or UNIX VMS) (merge-pathnames "lisptemp.lsp" (user-homedir-pathname))
  601. )
  602.  
  603. ;; (edit-file file) editiert ein File.
  604. (defun edit-file (file)
  605.   (unless *editor*
  606.     (error #+DEUTSCH "Kein externer Editor installiert."
  607.            #+ENGLISH "No external editor installed."
  608.            #+FRANCAIS "Un éditeur externe n'est pas installé."
  609.   ) )
  610.   #+ATARI
  611.     (prog1
  612.       (execute *editor* ; das ist der Name des Editors
  613.                (namestring file t) ; file als String, im GEMDOS-Format
  614.                (round (* 0.99 (gc))) ; Editor kriegt 99% des freien Speichers
  615.       )
  616.       (write-string (coerce '(#\Escape #\E) 'string) ; Bildschirm löschen
  617.                     *terminal-io*
  618.     ) )
  619.   #+(or DOS OS/2)
  620.     (execute *editor* ; das ist der Name des Editors
  621.              (namestring file) ; file als String
  622.     )
  623.   #+UNIX
  624.     (shell (format nil "~A ~A" *editor* (truename file)))
  625.   #+AMIGA
  626.     (execute (format nil "~A \"~A\"" *editor* (truename file)))
  627. )
  628.  
  629. (defun ed (&optional arg &aux sym fun def)
  630.   (if (null arg)
  631.     (edit-file "")
  632.     (if (or (pathnamep arg) (stringp arg))
  633.       (edit-file arg)
  634.       (if (and (cond ((symbolp arg) (setq sym arg) t)
  635.                      ((functionp arg) (setq sym (sys::%record-ref arg 0)) t)
  636.                      (t nil)
  637.                )
  638.                (fboundp sym)
  639.                (or (setq fun (macro-function sym))
  640.                    (setq fun (symbol-function sym))
  641.                )
  642.                (functionp fun)
  643.                (not (compiled-function-p fun))
  644.                (or (symbolp arg) (eql fun arg))
  645.                (setq def (get sym 'sys::definition))
  646.           )
  647.         (let ((env (vector (sys::%record-ref fun 4) ; venv
  648.                            (sys::%record-ref fun 5) ; fenv
  649.                            (sys::%record-ref fun 6) ; benv
  650.                            (sys::%record-ref fun 7) ; genv
  651.                            (sys::%record-ref fun 8) ; denv
  652.               )    )
  653.               (tempfile (editor-tempfile)))
  654.           (with-open-file (f tempfile :direction :output)
  655.             (pprint def f)
  656.             (terpri f) (terpri f)
  657.           )
  658.           (edit-file tempfile)
  659.           (with-open-file (f tempfile :direction :input)
  660.             (let ((*package* *package*) ; *PACKAGE* binden
  661.                   (end-of-file "EOF")) ; einmaliges Objekt
  662.               (loop
  663.                 (let ((obj (read f nil end-of-file)))
  664.                   (when (eql obj end-of-file) (return))
  665.                   (print (evalhook obj nil nil env))
  666.           ) ) ) )
  667.           sym
  668.         )
  669.         (error #+DEUTSCH "~S ist nicht editierbar."
  670.                #+ENGLISH "~S cannot be edited."
  671.                #+FRANCAIS "~S ne peut pas être édité."
  672.                arg
  673. ) ) ) ) )
  674.  
  675. ;-------------------------------------------------------------------------------
  676.  
  677. ; speichert den momentanen Speicherinhalt unter Weglassen überflüssiger
  678. ; Objekte ab als LISPINIT.MEM
  679. (defun saveinitmem ()
  680.   (do-all-symbols (sym) (remprop sym 'sys::definition))
  681.   (setq - nil + nil ++ nil +++ nil * nil ** nil *** nil / nil // nil /// nil)
  682.   (savemem "lispinit.mem")
  683.   (room)
  684. )
  685.  
  686. ;-------------------------------------------------------------------------------
  687.  
  688. ; Vervollständigungs-Routine in Verbindung mit der GNU Readline-Library:
  689. ; Input: string die Eingabezeile, (subseq string start end) das zu vervoll-
  690. ; ständigende Textstück.
  691. ; Output: eine Liste von Simple-Strings. Leer, falls keine sinnvolle Vervoll-
  692. ; ständigung. Sonst CDR = Liste aller sinnvollen Vervollständigungen, CAR =
  693. ; sofortige Ersetzung.
  694. #+(or UNIX DOS OS/2)
  695. (defun completion (string start end)
  696.   ; quotiert vervollständigen?
  697.   (let ((start1 start) (quoted nil))
  698.     (when (and (>= start 1) (member (char string (- start 1)) '(#\" #\|)))
  699.       (decf start1) (setq quoted t)
  700.     )
  701.     (let (; Hilfsvariablen beim Sammeln der Symbole:
  702.           knownpart ; Anfangsstück
  703.           knownlen  ; dessen Länge
  704.           (L '())   ; sammelnde Liste
  705.          )
  706.       (let ((gatherer
  707.               (if ; Vervollständigung in funktionaler Position?
  708.                 (or (and (>= start1 1)
  709.                          (equal (subseq string (- start1 1) start1) "(")
  710.                     )
  711.                     (and (>= start1 2)
  712.                          (equal (subseq string (- start1 2) start1) "#'")
  713.                 )   )
  714.                 #'(lambda (sym)
  715.                     (when (fboundp sym)
  716.                       (let ((name (symbol-name sym)))
  717.                         (when (and (>= (length name) knownlen) (string-equal name knownpart :end1 knownlen))
  718.                           (push name L)
  719.                   ) ) ) )
  720.                 #'(lambda (sym)
  721.                     (let ((name (symbol-name sym)))
  722.                       (when (and (>= (length name) knownlen) (string-equal name knownpart :end1 knownlen))
  723.                         (push name L)
  724.                   ) ) )
  725.             ) )
  726.             (package *package*)
  727.             (mapfun #'sys::map-symbols)
  728.             (prefix nil))
  729.         ; Evtl. Packagenamen abspalten:
  730.         (unless quoted
  731.           (let ((colon (position #\: string :start start :end end)))
  732.             (when colon
  733.               (unless (setq package (find-package (string-upcase (subseq string start colon))))
  734.                 (return-from completion nil)
  735.               )
  736.               (incf colon)
  737.               (if (and (< colon end) (eql (char string colon) #\:))
  738.                 (incf colon)
  739.                 (setq mapfun #'sys::map-external-symbols)
  740.               )
  741.               (setq prefix (subseq string start colon))
  742.               (setq start colon)
  743.         ) ) )
  744.         (setq knownpart (subseq string start end))
  745.         (setq knownlen (length knownpart))
  746.         (funcall mapfun gatherer package)
  747.         (when (null L) (return-from completion nil))
  748.         (unless quoted
  749.           (setq L (mapcar #'string-downcase L))
  750.         )
  751.         ; sortieren:
  752.         (setq L (sort L #'string<))
  753.         ; größtes gemeinsames Anfangsstück suchen:
  754.         (let ((imax ; (reduce #'min (mapcar #'length L))
  755.                 (let ((i (length (first L))))
  756.                   (dolist (s (rest L)) (setq i (min i (length s))))
  757.                   i
  758.              )) )
  759.           (do ((i 0 (1+ i)))
  760.               ((or (eql i imax)
  761.                    (let ((c (char (first L) i)))
  762.                      (dolist (s (rest L) nil) (unless (eql (char s i) c) (return t)))
  763.                )   )
  764.                (push (subseq (first L) 0 i) L)
  765.         ) )   )
  766.         ; Präfix wieder ankleben:
  767.         (when prefix
  768.           (mapl #'(lambda (l)
  769.                     (setf (car l) (string-concat prefix (car l)))
  770.                   )
  771.                 L
  772.         ) )
  773.         L
  774. ) ) ) )
  775.  
  776. ;-------------------------------------------------------------------------------
  777.  
  778. #+ATARI
  779. ; Unsere eigene kleine "Shell" interpretiert das erste Wort als
  780. ; auszuführendes Programm, den Rest als Argumentzeile.
  781. (defun myshell (command)
  782.   (declare (string command))
  783.   ; Whitespace zu Beginn der Zeile entfernen:
  784.   (let ((index (position-if-not #'whitespacep command)))
  785.     (unless index (return-from myshell))
  786.     (unless (eql index 0) (setq command (subseq command index)))
  787.   )
  788.   ; Nun ist (char command 0) kein Whitespace.
  789.   ; Aufspalten in Programm und Argumentzeile:
  790.   (let* ((index (or (position-if #'whitespacep command) (length command)))
  791.          (prog (subseq command 0 index))
  792.          proglist
  793.          (tail (subseq command
  794.                        (or (position-if-not #'whitespacep command :start index)
  795.                            (length command)
  796.         ))     )       )
  797.     (setq prog (pathname prog))
  798.     (setq proglist
  799.       (if (member :absolute (pathname-directory prog))
  800.         ; relativer Pfadname -> muß Programm im PATH suchen:
  801.         (let* ((pathstring (sys::getenv "PATH"))
  802.                (pathlist ; pathstring an den Strichpunkten aufspalten
  803.                  (and pathstring
  804.                    (let ((i 0) (l '()))
  805.                      (loop
  806.                        (let ((j (position #\; pathstring :start i)))
  807.                          (unless j (push (subseq pathstring i) l) (return))
  808.                          (push (subseq pathstring i j) l)
  809.                          (setq i (+ j 1))
  810.                      ) )
  811.                      (nreverse l)
  812.               )) ) )
  813.           (push "" pathlist) ; aktuelles Directory zuerst
  814.           (setq pathlist (delete-duplicates pathlist :from-end t :test #'equal))
  815.           (setq pathlist
  816.             (mapcar #'(lambda (path)
  817.                         (pathname
  818.                           (if (and (plusp (length path))
  819.                                    (not (eql (char path (1- (length path))) #\\))
  820.                               )
  821.                             (string-concat path "\\")
  822.                             path
  823.                       ) ) )
  824.                     pathlist
  825.           ) )
  826.           (mapcar #'(lambda (path) (merge-pathnames prog path)) pathlist)
  827.         )
  828.         ; absoluter Pfadname -> brauche nicht zu suchen:
  829.         (list prog)
  830.     ) )
  831.     ; Extensions ergänzen:
  832.     (when (null (pathname-type prog))
  833.       (setq proglist
  834.         (mapcan #'(lambda (prog)
  835.                     (list (merge-pathnames prog '#".prg")
  836.                           (merge-pathnames prog '#".ttp")
  837.                           (merge-pathnames prog '#".tos")
  838.                   ) )
  839.                 proglist
  840.     ) ) )
  841.     ; Programm suchen:
  842.     (setq prog (find-if #'probe-file proglist))
  843.     (when prog
  844.       (execute prog tail)
  845. ) ) )
  846.  
  847.